home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / programm.ing / gfa / gfaexprt.lzh / GFAXPERT.LIB / FILE.LST < prev    next >
Encoding:
File List  |  1986-10-19  |  10.2 KB  |  406 lines
  1. ' ****************
  2. ' *** FILE.LST ***
  3. ' ****************
  4. '
  5. DEFWRD "a-z"
  6. '
  7. > PROCEDURE file.length(file$,VAR length%)
  8.   ' *** length of file (bytes)
  9.   OPEN "I",#99,file$
  10.   length%=LOF(#99)
  11.   CLOSE #99
  12. RETURN
  13. ' **********
  14. '
  15. > PROCEDURE parse.filename(parse.name$,VAR drive$,path$,file$,ext$)
  16.   ' *** return drive, path, filename (without extension !) and extension
  17.   ' *** no checking for correct syntax
  18.   ' *** example : "A:\GAMES\PLAY.GFA" returned as :  A  \GAMES\  PLAY  GFA
  19.   ' ***           "A:\PLAY.GFA"       returned as :  A  \        PLAY  GFA
  20.   LOCAL pos,first,last,last!,search,parse.file$
  21.   '
  22.   parse.name$=UPPER$(parse.name$)
  23.   IF MID$(parse.name$,2,1)=":"
  24.     drive$=LEFT$(parse.name$,1)
  25.   ELSE
  26.     drive$=CHR$(65+GEMDOS(&H19))    ! current drive
  27.   ENDIF
  28.   '
  29.   pos=1
  30.   last!=FALSE
  31.   last=0
  32.   first=INSTR(1,parse.name$,"\")
  33.   REPEAT
  34.     search=INSTR(pos,parse.name$,"\")
  35.     IF search>0
  36.       pos=search+1
  37.       last=search
  38.     ELSE
  39.       last!=TRUE
  40.     ENDIF
  41.   UNTIL last!
  42.   IF last>0                              ! backslash discovered
  43.     path$=MID$(parse.name$,first,last-first+1)
  44.     parse.file$=MID$(parse.name$,last+1)
  45.   ELSE                                   ! no '\'
  46.     path$=""
  47.     pos=INSTR(1,parse.name$,":")
  48.     IF pos>0
  49.       parse.file$=MID$(parse.name$,pos+1)
  50.     ELSE
  51.       parse.file$=parse.name$
  52.     ENDIF
  53.   ENDIF
  54.   pos=INSTR(parse.file$,".")
  55.   IF pos>0                               ! name with extension
  56.     ext$=MID$(parse.file$,pos+1)
  57.     file$=LEFT$(parse.file$,pos-1)
  58.   ELSE                                   ! name without extension
  59.     ext$=""
  60.     file$=parse.file$
  61.   ENDIF
  62. RETURN
  63. ' **********
  64. '
  65. > PROCEDURE get.path(VAR default.path$)
  66.   ' *** return default path (current drive and folder)
  67.   ' *** example - A:\GAMES\
  68.   ' *** WARNING : Procedure returns path$ only after CHDIR path$, else A:\
  69.   ' ***                          (even if program not in main directory !!)
  70.   LOCAL default.drive,default.drive$
  71.   CLR default.path$
  72.   default.drive=GEMDOS(&H19)
  73.   default.drive$=CHR$(default.drive+65)
  74.   default.path$=DIR$(default.drive+1)
  75.   IF default.path$<>""
  76.     default.path$=default.drive$+":"+default.path$+"\"
  77.   ELSE
  78.     default.path$=default.drive$+":\"
  79.   ENDIF
  80. RETURN
  81. ' **********
  82. '
  83. > PROCEDURE file.copy(source$,dest$)
  84.   ' *** copy file source$ to dest$
  85.   ' *** global :  FILE.COPY!
  86.   LOCAL m$,k,p,file$,block%
  87.   IF source$=dest$      ! protect user against disaster
  88.     m$="File-copy|aborted|(source =|destination)"
  89.     ALERT 3,m$,1,"OK",k
  90.     file.copy!=FALSE
  91.   ELSE
  92.     IF EXIST(dest$)
  93.       m$=UPPER$(dest$)+"|already exists:|Kill file, or|Rename as *.BAK"
  94.       ALERT 3,m$,0,"KILL|BAK",k
  95.       IF k=1
  96.         KILL dest$
  97.       ELSE
  98.         p=INSTR(dest$,".")
  99.         IF p>0
  100.           file$=LEFT$(dest$,p)+"BAK"
  101.         ELSE
  102.           file$=dest$+".BAK"
  103.         ENDIF
  104.         RENAME dest$ AS file$
  105.       ENDIF
  106.     ENDIF
  107.     OPEN "I",#90,source$
  108.     OPEN "O",#91,dest$
  109.     block%=LOF(#90)
  110.     WHILE block%>32000
  111.       PRINT #91,INPUT$(32000,#90);
  112.       SUB block%,32000
  113.     WEND
  114.     PRINT #91,INPUT$(block%,#90);
  115.     CLOSE #90
  116.     CLOSE #91
  117.     file.copy!=TRUE
  118.   ENDIF
  119. RETURN
  120. ' **********
  121. '
  122. > PROCEDURE file.move(source$,dest$)
  123.   ' *** move file source$ to dest$ (source$ is killed after copy)
  124.   ' *** global :  FILE.MOVE!
  125.   LOCAL m$,k,p,file$,block%
  126.   IF source$=dest$      ! protect user against disaster
  127.     m$="File-move|aborted|(source =|destination)"
  128.     ALERT 3,m$,1," OK ",k
  129.     file.move!=FALSE
  130.   ELSE
  131.     IF EXIST(dest$)
  132.       m$=UPPER$(dest$)+"|already exists:|Kill file, or|Rename as *.BAK"
  133.       ALERT 3,m$,0,"KILL|BAK",k
  134.       IF k=1
  135.         KILL dest$
  136.       ELSE
  137.         p=INSTR(dest$,".")
  138.         IF p>0
  139.           file$=LEFT$(dest$,p)+"BAK"
  140.         ELSE
  141.           file$=dest$+".BAK"
  142.         ENDIF
  143.         RENAME dest$ AS file$
  144.       ENDIF
  145.     ENDIF
  146.     OPEN "I",#90,source$
  147.     OPEN "O",#91,dest$
  148.     block%=LOF(#90)
  149.     WHILE block%>32000
  150.       PRINT #91,INPUT$(32000,#90);
  151.       SUB block%,32000
  152.     WEND
  153.     PRINT #91,INPUT$(block%,#90);
  154.     CLOSE #90
  155.     CLOSE #91
  156.     KILL source$
  157.     file.move!=TRUE
  158.   ENDIF
  159. RETURN
  160. ' **********
  161. '
  162. > PROCEDURE execute.prg(file$,bytes%,cmd$)
  163.   ' *** reserve memory and start program file$
  164.   LOCAL free%,m$,k
  165.   IF cmd$<>""
  166.     cmd$=CHR$(LEN(cmd$)+1)+cmd$     ! special commandline-format
  167.   ENDIF
  168.   free%=FRE()
  169.   IF bytes%>free%
  170.     m$="Sorry, insufficient|memory for running|"+file$+"|available"
  171.     ALERT 3,m$,1,"EDIT",k
  172.     EDIT
  173.   ELSE
  174.     RESERVE -bytes%
  175.     SHOWM
  176.     EXEC 0,file$,cmd$,""  ! start program
  177.     RESERVE               ! back to GFA-Basic ; return memory to GFA
  178.   ENDIF
  179. RETURN
  180. ' **********
  181. '
  182. > PROCEDURE load.file(file$)
  183.   ' *** put file in RAM
  184.   ' *** don't forget to release memory again with RESERVE !!
  185.   LOCAL bytes%,free%,adres%,m$,k
  186.   OPEN "I",#90,file$
  187.   bytes%=LOF(#90)
  188.   CLOSE #90
  189.   free%=FRE()
  190.   IF free%>bytes%
  191.     RESERVE -bytes%
  192.     adres%=HIMEM            ! should adres% be even ??
  193.     BLOAD file$,adres%
  194.   ELSE
  195.     m$="not enough memory|for loading|"+file$
  196.     ALERT 3,m$,1,"EDIT",k
  197.     EDIT
  198.   ENDIF
  199. RETURN
  200. ' **********
  201. '
  202. > PROCEDURE activate.accessory
  203.   ' *** activate accessory by changing extension .ACX into .ACC
  204.   ' *** accessories have to be in main directory
  205.   ' *** uses Procedure Fileselect
  206.   LOCAL file$,acc$,m$,k
  207.   DO
  208.     CLS
  209.     @fileselect("\*.ACX","","Activate accessories  (<Cancel> = Stop)",file$)
  210.     EXIT IF file$="" OR RIGHT$(file$)="\"
  211.     acc$=LEFT$(file$,INSTR(file$,".")-1)
  212.     NAME file$ AS acc$+".ACC"
  213.   LOOP
  214.   m$="|reset computer ?"
  215.   ALERT 3,m$,0,"YES| NO",k
  216.   IF k=1
  217.     VOID XBIOS(38,L:LPEEK(4))
  218.   ENDIF
  219. RETURN
  220. ' ***
  221. > PROCEDURE remove.accessory
  222.   ' *** deactivate accessory by changing extension .ACC into .ACX
  223.   ' *** uses Procedure Fileselect
  224.   LOCAL file$,acc$,m$,k
  225.   DO
  226.     CLS
  227.     PRINT " Deactivate accessories (<Cancel> = Stop)"
  228.     FILESELECT "\*.ACC","",file$
  229.     @fileselect("\*.ACC","","Deactivate accessories  (<Cancel> = Stop)",file$)
  230.     EXIT IF file$="" OR RIGHT$(file$)="\"
  231.     acc$=LEFT$(file$,INSTR(file$,".")-1)
  232.     NAME file$ AS acc$+".ACX"
  233.   LOOP
  234.   m$="|reset computer ?"
  235.   ALERT 3,m$,0,"YES| NO",k
  236.   IF k=1
  237.     VOID XBIOS(38,L:LPEEK(4))
  238.   ENDIF
  239. RETURN
  240. ' **********
  241. '
  242. > PROCEDURE get.archive(arch$,VAR set!)
  243.   ' *** examine archive-bit of file arch$
  244.   LOCAL flag
  245.   flag=FSFIRST(arch$,32)
  246.   IF flag=0
  247.     set!=TRUE
  248.   ELSE
  249.     set!=FALSE
  250.   ENDIF
  251. RETURN
  252. ' **********
  253. '
  254. > PROCEDURE get.file.attributes(get.file$)
  255.   ' *** return file-attributes of file
  256.   ' *** global :  ATTR.READ.ONLY!  ATTR.HIDDEN!  ATTR.SYSTEM!  ATTR.LABEL!
  257.   ' ***           ATTR.FOLDER!  ATTR.ARCHIVE!
  258.   LOCAL path$,path%,attr%,k
  259.   path$=get.file$+CHR$(0)
  260.   path%=V:path$
  261.   attr%=GEMDOS(&H43,L:path%,0,0)
  262.   IF attr%=-33
  263.     ALERT 3," *** file-error ***| |"+get.file$+"|not found",1," OK ",k
  264.   ELSE IF attr%=-34
  265.     ALERT 3," *** path-error ***| |"+get.file$+"|not found",1," OK ",k
  266.   ENDIF
  267.   CLR attr.read.only!,attr.hidden!,attr.system!,attr.label!,attr.folder!,attr.archive!
  268.   IF attr%<>-33 AND attr%<>-34
  269.     IF BTST(attr%,0)
  270.       attr.read.only!=TRUE
  271.     ENDIF
  272.     IF BTST(attr%,1)
  273.       attr.hidden!=TRUE
  274.     ENDIF
  275.     IF BTST(attr%,2)
  276.       attr.system!=TRUE
  277.     ENDIF
  278.     IF BTST(attr%,3)
  279.       attr.label!=TRUE
  280.     ENDIF
  281.     IF BTST(attr%,4)
  282.       attr.folder!=TRUE
  283.     ENDIF
  284.     IF BTST(attr%,5)
  285.       attr.archive!=TRUE
  286.     ENDIF
  287.   ENDIF
  288. RETURN
  289. ' **********
  290. '
  291. > PROCEDURE set.file.attributes(set.file$,read.only!,hidden!,system!,archive!)
  292.   ' *** set file-attributes of file
  293.   LOCAL path$,path%,attr,a%,k
  294.   path$=set.file$+CHR$(0)
  295.   attr=0
  296.   IF read.only!
  297.     attr=BSET(attr,0)
  298.   ENDIF
  299.   IF hidden!
  300.     attr=BSET(attr,1)
  301.   ENDIF
  302.   IF system!
  303.     attr=BSET(attr,2)
  304.   ENDIF
  305.   IF archive!
  306.     attr=BSET(attr,5)
  307.   ENDIF
  308.   a%=GEMDOS(&H43,L:path%,1,attr)
  309.   IF a%=-33
  310.     ALERT 3," *** file-error ***| |"+set.file$+"|not found",1," OK ",k
  311.   ELSE IF a%=-34
  312.     ALERT 3," *** path-error ***| |"+set.file$+"|not found",1," OK ",k
  313.   ENDIF
  314. RETURN
  315. ' **********
  316. '
  317. > PROCEDURE scrap.write(txt$)
  318.   ' *** send message (<160 bytes) through scrap-library
  319.   ' *** receiving program uses Procedure Scrap.read
  320.   LOCAL buffer$,r%,m$,k
  321.   buffer$=SPACE$(160)
  322.   txt$=txt$+CHR$(0)
  323.   LSET buffer$=txt$
  324.   r%=SCRP_WRITE(buffer$)
  325.   IF r%=0
  326.     m$="scrap-library| |*** error ***"
  327.     ALERT 3,m$,1,"EDIT",k
  328.     EDIT
  329.   ENDIF
  330. RETURN
  331. ' ***********
  332. '
  333. > PROCEDURE scrap.read(VAR txt$)
  334.   ' *** read scrap-library
  335.   LOCAL buffer$,r%,m$,k
  336.   buffer$=SPACE$(160)
  337.   r%=SCRP_READ(buffer$)
  338.   IF r%=0
  339.     m$="scrap-library| |*** error ***"
  340.     ALERT 3,m$,1,"EDIT",k
  341.     EDIT
  342.   ENDIF
  343.   txt$=CHAR{V:buffer$}
  344. RETURN
  345. ' **********
  346. '
  347. > PROCEDURE fileselect(path$,default$,txt$,left$,right$,VAR file$)
  348.   ' *** use Fileselector with comment-line in High or Medium resolution
  349.   ' *** print optional title (light text) to the left and right of Fileselector
  350.   ' *** comment-line max. 38 characters
  351.   ' *** uses Standard Function and Globals
  352.   LOCAL screen$,y.fac
  353.   SGET screen$          ! delete if not necessary
  354.   CLS
  355.   IF high.res!
  356.     y.fac=1
  357.   ELSE
  358.     y.fac=2
  359.   ENDIF
  360.   DEFTEXT black,2,900,32
  361.   TEXT 100,350/y.fac,300/y.fac,left$
  362.   DEFTEXT ,,2700
  363.   TEXT 540,50/y.fac,300/y.fac,right$
  364.   DEFTEXT ,0,0,13
  365.   PRINT AT(1,3);@center$(txt$)
  366.   GRAPHMODE 3
  367.   DEFFILL 1,1           ! black
  368.   BOUNDARY 0
  369.   IF high.res!
  370.     BOX 157,25,482,54
  371.     PLOT 157,25
  372.     PBOX 159,27,480,52
  373.   ELSE
  374.     BOX 157,12,482,27
  375.     PLOT 157,12
  376.     PBOX 160,14,479,24
  377.   ENDIF
  378.   BOUNDARY 1
  379.   GRAPHMODE 1
  380.   FILESELECT path$,default$,file$
  381.   SPUT screen$          ! delete if not necessary
  382. RETURN
  383. ' **********
  384. '
  385. > PROCEDURE fileselect.low(path$,default$,txt$,VAR file$)
  386.   ' *** use Fileselector with comment-line in Low-resolution
  387.   ' *** comment-line max. 38 characters
  388.   ' *** uses Standard Function and Globals
  389.   LOCAL screen$
  390.   SGET screen$          ! delete if not necessary
  391.   CLS
  392.   PRINT AT(1,3);@center$(txt$)
  393.   GRAPHMODE 3
  394.   DEFFILL 1,1           ! black
  395.   BOUNDARY 0
  396.   BOX 0,12,319,27
  397.   PLOT 0,12
  398.   PBOX 2,14,317,24
  399.   BOUNDARY 1
  400.   GRAPHMODE 1
  401.   FILESELECT path$,default$,file$
  402.   SPUT screen$          ! delete if not necessary
  403. RETURN
  404. ' **********
  405. '
  406.